home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / DEBUG / DTRACE32 / UTRACE.PAS < prev   
Pascal/Delphi Source File  |  1996-09-24  |  12KB  |  516 lines
  1. unit UTrace;
  2. interface
  3. uses
  4.     Windows,Messages,Classes,Forms,SysUtils;
  5. type
  6.     TDebugSeverity = (cNone,cInfo,cWarning,cError);
  7.  
  8. procedure Assert(Condition : Boolean;TheText : String);
  9. procedure AssertFmt(Condition : Boolean;TheFormat : String;const Args: Array of const);
  10. procedure DebugDump(TheText : String;Address : Pointer;Count : Integer);
  11. procedure Debug(TheSeverity : TDebugSeverity;TheText : String);
  12. procedure DebugFmt(TheSeverity : TDebugSeverity;TheFormat : String;const Args: Array of const);
  13. procedure DebugInfo(TheText : String);
  14. procedure DebugInfoFmt(TheFormat : String;const Args: Array of const);
  15. procedure DebugWarn(TheText : String);
  16. procedure DebugWarnFmt(TheFormat : String;const Args: Array of const);
  17. procedure DebugErr(TheText : String);
  18. procedure DebugErrFmt(TheFormat : String;const Args: Array of const);
  19.  
  20. implementation
  21. {$StackFrames On}
  22. {$DebugInfo Off}
  23. type
  24.     Tcds = Record
  25.         dwData : Integer;
  26.         cbData : Integer;
  27.         lpData : Pointer;
  28.     end;
  29.  
  30.     TDebugStruct = Record
  31.         dwSize : Integer;
  32.         dwCodeAddress : Integer;
  33.         dwLineNumber : Integer;
  34.         SystemTime : TSystemTime;
  35.         Severity : Byte;
  36.         Data : Array[0..MaxInt-50] of Char;
  37.     end;
  38.     pTDebugStruct = ^TDebugStruct;
  39.  
  40.     TRange = class
  41.         Start,LineNum : Integer;
  42.         ModuleIndex : Word;
  43.     end;
  44.  
  45.     TRange1 = class
  46.         Start : Integer;
  47.         ProcName : String;
  48.     end;
  49.  
  50.     TRangeList = class(TList)
  51.         { This is a list of ranges of addresses to report }
  52.         destructor destroy; override;
  53.         procedure FreeAll;
  54.         { Frees all the ranges }
  55.         function Find(target:Integer):Integer;
  56.         { Checks whether start <= target <= stop
  57.         for some entry in the list }
  58.         procedure ReadMapFile(filename:string);
  59.         procedure ReadMapFile1(Filename:string);
  60.         { Reads a .MAP file to initialize }
  61.     end;
  62.  
  63. var
  64.     SaveExit : Pointer;
  65.     Range : TRange;
  66.     Range1 : TRange1;
  67.     RangeList,
  68.     RangeList1 : TRangeList;
  69.     ModuleList : TStringList;
  70.     pDebug : pTDebugStruct;
  71.     Mapshift : integer;
  72.  
  73. function ConvertAddr(Address: Pointer): Pointer; assembler;
  74. asm
  75.     TEST    EAX,EAX         { Always convert nil to nil }
  76.     JE      @@1
  77.     SUB     EAX,OFFSET TextStart
  78. @@1:
  79. end;
  80.  
  81. procedure _Debug(BasePointer : pointer;TheSeverity : TDebugSeverity;TheText : String);
  82. var
  83.     cds : Tcds;
  84.     TheWindow : THandle;
  85.     MemNeeded : Integer;
  86.     SourceAddr : Integer;
  87.     ModuleText : String;
  88.     SourceIndex,
  89.     ProcIndex : Integer;
  90. begin
  91.     TheWindow := FindWindow('TTraceForm',Nil);
  92.     if TheWindow <> 0 then
  93.     begin
  94.         pChar(BasePointer) := pChar(BasePointer)+4;
  95.         SourceAddr := LongInt(BasePointer^);
  96.         SourceAddr := SourceAddr-5;
  97.         GetSystemTime(pDebug^.SystemTime);
  98.  
  99.         SourceIndex := RangeList.Find(SourceAddr);
  100.         ProcIndex := RangeList1.Find(SourceAddr);
  101.         ModuleText := TRange1(RangeList1.Items[ProcIndex]).ProcName;
  102.         ModuleText := ModuleText + ' ' + ModuleList.Strings[TRange(RangeList.Items[SourceIndex]).ModuleIndex];
  103.         MemNeeded := Integer(pChar(@pDebug^.Data) - pChar(@pDebug^.dwSize)) + Length(ModuleText)+ 1 + Length(TheText) + 1;
  104.         pDebug^.dwSize := MemNeeded;
  105.         pDebug^.dwLineNumber := TRange(RangeList.Items[SourceIndex]).LineNum;
  106.         pDebug^.dwCodeAddress := SourceAddr-MapShift;
  107.         pDebug^.Severity := Byte(TheSeverity);
  108.         StrPCopy(pDebug^.Data,ModuleText);
  109.         StrPCopy(pChar(@pDebug^.Data[Length(ModuleText)+1]),TheText);
  110.         cds.dwData := 0;
  111.         cds.cbData := MemNeeded;
  112.         cds.lpData := pDebug;
  113.         if Assigned(Application.MainForm) then
  114.             SendMessage(TheWindow,WM_COPYDATA,Application.MainForm.Handle,Longint(@cds))
  115.         else
  116.             SendMessage(TheWindow,WM_COPYDATA,0,Longint(@cds));
  117.     end;
  118. end;
  119.  
  120. procedure Assert(Condition : Boolean;TheText : String);
  121. var
  122.     BasePointer : ^LongInt;
  123. begin
  124.     asm
  125.         mov BasePointer,ebp
  126.     end;
  127.     if not Condition then
  128.     begin
  129.         _Debug(BasePointer,cError,TheText);
  130.     end;
  131.     halt;
  132. end;
  133.  
  134. procedure AssertFmt(Condition : Boolean;TheFormat : String;const Args: Array of const);
  135. var
  136.     BasePointer : ^LongInt;
  137.     TheText : String;
  138. begin
  139.     asm
  140.         mov BasePointer,ebp
  141.     end;
  142.     if not Condition then
  143.     begin
  144.         FmtStr(TheText,TheFormat,Args);
  145.         _Debug(BasePointer,cError,TheText);
  146.     end;
  147.     halt;
  148. end;
  149.  
  150. procedure DebugDump(TheText : String;Address : Pointer;Count : Integer);
  151. var
  152.     BasePointer : ^LongInt;
  153.     TheText1 : String;
  154.     i : Integer;
  155. begin
  156.     asm
  157.         mov BasePointer,ebp
  158.     end;
  159.     FmtStr(TheText1,'%.8x:',[LongInt(Address)]);
  160.     TheText := TheText + #13 + TheText1;
  161.     for i := 0 to Count-1 do
  162.     begin
  163.         FmtStr(TheText1,'%.2x ',[Byte((pChar(Address)+i)^)]);
  164.         TheText := TheText + TheText1;
  165.         if (LongInt(Address)+i) mod 16 = 15 then
  166.         begin
  167.             FmtStr(TheText1,'%.8x:',[LongInt(Address)+i+1]);
  168.             TheText := TheText + #13 + TheText1;
  169.         end;
  170.     end;
  171.     _Debug(BasePointer,cInfo,TheText);
  172. end;
  173.  
  174. procedure DebugInfo(TheText : String);
  175. var
  176.     BasePointer : ^LongInt;
  177. begin
  178.     asm
  179.         mov BasePointer,ebp
  180.     end;
  181.     _Debug(BasePointer,cInfo,TheText);
  182. end;
  183.  
  184. procedure DebugInfoFmt(TheFormat : String;const Args: Array of const);
  185. var
  186.     BasePointer : ^LongInt;
  187.     TheText : String;
  188. begin
  189.     asm
  190.         mov BasePointer,ebp
  191.     end;
  192.     FmtStr(TheText,TheFormat,Args);
  193.     _Debug(BasePointer,cInfo,TheText);
  194. end;
  195.  
  196. procedure DebugWarn(TheText : String);
  197. var
  198.     BasePointer : ^LongInt;
  199. begin
  200.     asm
  201.         mov BasePointer,ebp
  202.     end;
  203.     _Debug(BasePointer,cWarning,TheText);
  204. end;
  205.  
  206. procedure DebugWarnFmt(TheFormat : String;const Args: Array of const);
  207. var
  208.     BasePointer : ^LongInt;
  209.     TheText : String;
  210. begin
  211.     asm
  212.         mov BasePointer,ebp
  213.     end;
  214.     FmtStr(TheText,TheFormat,Args);
  215.     _Debug(BasePointer,cWarning,TheText);
  216. end;
  217.  
  218. procedure DebugErr(TheText : String);
  219. var
  220.     BasePointer : ^LongInt;
  221. begin
  222.     asm
  223.         mov BasePointer,ebp
  224.     end;
  225.     _Debug(BasePointer,cError,TheText);
  226. end;
  227.  
  228. procedure DebugErrFmt(TheFormat : String;const Args: Array of const);
  229. var
  230.     BasePointer : ^LongInt;
  231.     TheText : String;
  232. begin
  233.     asm
  234.         mov BasePointer,ebp
  235.     end;
  236.     FmtStr(TheText,TheFormat,Args);
  237.     _Debug(BasePointer,cError,TheText);
  238. end;
  239.  
  240. procedure DebugFmt(TheSeverity : TDebugSeverity;TheFormat : String;const Args: Array of const);
  241. var
  242.     BasePointer : ^LongInt;
  243.     TheText : String;
  244. begin
  245.     asm
  246.         mov BasePointer,ebp
  247.     end;
  248.     FmtStr(TheText,TheFormat,Args);
  249.     _Debug(BasePointer,TheSeverity,TheText);
  250. end;
  251.  
  252. procedure Debug(TheSeverity : TDebugSeverity;TheText : String);
  253. var
  254.     BasePointer : ^LongInt;
  255. begin
  256.     asm
  257.         mov BasePointer,ebp
  258.     end;
  259.     _Debug(BasePointer,TheSeverity,TheText);
  260. end;
  261.  
  262. procedure TRangeList.FreeAll;
  263. var
  264.     i : integer;
  265. begin
  266.     for i := 0 to pred(Count) do
  267.         TRange(Items[i]).Free;
  268.     Count := 0;
  269. end;
  270.  
  271. destructor TRangeList.Destroy;
  272. begin
  273.     FreeAll;
  274.     inherited Destroy;
  275. end;
  276.  
  277. function TRangeList.Find(Target:Integer):Integer;
  278. var
  279.     ThePos : Integer;
  280. procedure Seek(MinPos,MaxPos  : Integer);
  281. var
  282.     iMinPos,iMaxPos : Integer;
  283. begin
  284.     if MaxPos-MinPos = 0 then
  285.         ThePos := MaxPos
  286.     else
  287.     begin
  288.     if MaxPos-MinPos = 1 then
  289.     begin
  290.         if TRange(Items[MaxPos]).Start > Target then
  291.         begin
  292.             iMinPos := MinPos;
  293.             iMaxPos := MinPos;
  294.         end
  295.         else
  296.         begin
  297.             iMinPos := MaxPos;
  298.             iMaxPos := MaxPos;
  299.         end;
  300.     end
  301.     else
  302.     begin
  303.         ThePos := MinPos + (MaxPos-MinPos) div 2;
  304.         if TRange(Items[ThePos]).Start = Target then
  305.         begin
  306.             iMinPos := ThePos;
  307.             iMaxPos := ThePos;
  308.         end
  309.         else if TRange(Items[ThePos]).Start < Target then
  310.         begin
  311.             iMinPos := ThePos;
  312.             iMaxPos := MaxPos;
  313.         end
  314.         else if TRange(Items[ThePos]).Start > Target then
  315.         begin
  316.             iMinPos := MinPos;
  317.             iMaxPos := ThePos;
  318.         end;
  319.     end;
  320.     if iMinPos <> iMaxPos then
  321.         Seek(IMinPos,IMaxPos)
  322.     else
  323.         ThePos := iMinPos;
  324.     end;
  325. end;
  326.  
  327. begin
  328.     Seek(0,Count-1);
  329.     Result := ThePos
  330. end;
  331.  
  332. procedure TRangeList.ReadMapFile(Filename:string);
  333. var
  334.     Map : textfile;
  335.     Line : string;
  336.     Buffer : array[1..8192] of byte;
  337.     StartModuleName,
  338.     EndModuleName,
  339.     ModuleIndex : Integer;
  340.     a : Pointer;
  341. begin
  342.     a := ConvertAddr(@Self);
  343.     Mapshift := Integer(pChar(@Self)-pChar(a));
  344.     MapShift := MapShift - 512;
  345.     ModuleIndex := 0;
  346.     AssignFile(Map,Filename);
  347.     SetTextBuf(Map,Buffer);
  348.     {$i-}
  349.     Reset(Map);
  350.     {$i+}
  351.     if IoResult = 0 then
  352.     begin
  353.         while not Eof(Map) do
  354.         begin
  355.             Readln(Map,Line);
  356.             if Pos('Publics by Value',Line) > 0 then
  357.                 break;
  358.         end;
  359.         while not Eof(Map) do
  360.         begin
  361.             Readln(Map,Line);
  362.             if Pos('TextStart',Line) > 0 then
  363.             begin
  364.                 Mapshift := Integer(@TextStart) - StrToInt('$'+Copy(line,7,8));
  365.                 break;
  366.             end;
  367.         end;
  368.         while not Eof(Map) do
  369.         begin
  370.             readln(Map,Line);
  371.             if pos('Line numbers for ',Line) > 0 then
  372.             begin
  373.                 StartModuleName := Pos('(',Line);
  374.                 StartModuleName := StartModuleName+1;
  375.                 EndModuleName := Pos(')',Line);
  376.                 ModuleList.Add(ExtractFileName(Copy(Line,StartModuleName,EndModuleName-StartModuleName)));
  377.                 ModuleIndex := ModuleList.Count -1;
  378.                 break;
  379.             end;
  380.         end;
  381.         while not eof(Map) do
  382.         begin
  383.             readln(Map,Line);
  384.             if pos('Program entry point',Line) <> 0 then
  385.                 break;
  386.             if pos('Line numbers for ',Line) > 0 then
  387.             begin
  388.                 StartModuleName := Pos('(',Line);
  389.                 StartModuleName := StartModuleName+1;
  390.                 EndModuleName := Pos(')',Line);
  391.                 ModuleList.Add(ExtractFileName(Copy(Line,StartModuleName,EndModuleName-StartModuleName)));
  392.                 ModuleIndex := ModuleList.Count -1;
  393.             end
  394.             else
  395.             begin
  396.                 if Length(Line) > 19 then
  397.                 begin
  398.                     Range := TRange.Create;
  399.                     Range.Start := Mapshift + StrToInt('$'+Copy(Line,13,8));
  400.                     Range.LineNum := StrToInt(Copy(Line,1,6));
  401.                     Range.ModuleIndex := ModuleIndex;
  402.                     Add(Range);
  403.                 end;
  404.                 if Length(Line) > 39 then
  405.                 begin
  406.                     Range := TRange.Create;
  407.                     Range.Start := Mapshift + StrToInt('$'+Copy(Line,33,8));
  408.                     Range.LineNum := StrToInt(Copy(Line,21,6));
  409.                     Range.ModuleIndex := ModuleIndex;
  410.                     Add(Range);
  411.                 end;
  412.                 if Length(Line) > 59 then
  413.                 begin
  414.                     Range := TRange.Create;
  415.                     Range.Start := Mapshift + StrToInt('$'+Copy(Line,53,8));
  416.                     Range.LineNum := StrToInt(Copy(Line,41,6));
  417.                     Range.ModuleIndex := ModuleIndex;
  418.                     Add(Range);
  419.                 end;
  420.                 if Length(Line) > 79 then
  421.                 begin
  422.                     Range := TRange.Create;
  423.                     Range.Start := Mapshift + StrToInt('$'+Copy(Line,73,8));
  424.                     Range.LineNum := StrToInt(Copy(Line,61,6));
  425.                     Range.ModuleIndex := ModuleIndex;
  426.                     Add(Range);
  427.                 end;
  428.                 if Capacity - Count < 10 then
  429.                     Capacity := Capacity + 50;
  430.             end;
  431.         end;
  432.         Closefile(Map);
  433.     end;
  434. end;
  435.  
  436. procedure TRangeList.ReadMapFile1(Filename:string);
  437. var
  438.     Map : textfile;
  439.     Line : string;
  440.     Buffer : array[1..8192] of byte;
  441. begin
  442.     AssignFile(Map,Filename);
  443.     SetTextBuf(Map,Buffer);
  444.     {$i-}
  445.     Reset(Map);
  446.     {$i+}
  447.     if IoResult = 0 then
  448.     begin
  449.         while not Eof(Map) do
  450.         begin
  451.             Readln(Map,Line);
  452.             if Pos('Publics by Value',Line) > 0 then
  453.                 break;
  454.         end;
  455.         while not eof(Map) do
  456.         begin
  457.             readln(Map,Line);
  458.             if pos('Line numbers for',Line) <> 0 then
  459.                 break;
  460.             if pos('0001:',Line) <> 0 then
  461.             begin
  462.                 Range1 := TRange1.Create;
  463.                 Range1.Start := Mapshift + StrToInt('$'+Copy(Line,7,8));
  464.                 Range1.ProcName := Copy(Line,22,99);
  465.                 Add(Range1);
  466.             end;
  467.             if Capacity - Count < 10 then
  468.                    Capacity := Capacity + 50;
  469.         end;
  470.         Closefile(Map);
  471.     end;
  472. end;
  473.  
  474. procedure MyExit;
  475. begin
  476.     ExitProc := SaveExit;
  477.     if Assigned(pDebug) then
  478.         FreeMem(pDebug);
  479.     if Assigned(RangeList) then
  480.     begin
  481.         RangeList.Destroy;
  482.     end;
  483.     if Assigned(RangeList1) then
  484.     begin
  485.         RangeList1.Destroy;
  486.     end;
  487.     if Assigned(ModuleList) then
  488.     begin
  489.         ModuleList.Destroy;
  490.     end;
  491. end;
  492.  
  493. begin
  494.     ModuleList := TStringList.Create;
  495.     ModuleList.Add(ExtractFileName(Application.ExeName));
  496.  
  497.     RangeList := TRangeList.Create;
  498.     RangeList1 := TRangeList.Create;
  499.     Range := TRange.Create;
  500.     Range.Start := 0;
  501.     Range.LineNum := 0;
  502.     Range.ModuleIndex := 0;
  503.     RangeList.Add(Range);
  504.     Range1 := TRange1.Create;
  505.     Range1.Start := 0;
  506.     Range1.ProcName := '';
  507.     RangeList1.Add(Range1);
  508.  
  509.     RangeList.ReadMapFile(ChangeFileExt(Application.ExeName,'.map'));
  510.     RangeList1.ReadMapFile1(ChangeFileExt(Application.ExeName,'.map'));
  511.  
  512.     GetMem(pDebug,2000);
  513.     SaveExit := ExitProc;
  514.     ExitProc := @MyExit;
  515. end.
  516.